home *** CD-ROM | disk | FTP | other *** search
/ Cream of the Crop 1 / Cream of the Crop 1.iso / MONITOR / KABLOO.ARJ / KABLOOIE.PAS < prev   
Pascal/Delphi Source File  |  1991-06-19  |  7KB  |  370 lines
  1. program kablooie;
  2. uses crt,bgi256,graph,colour;
  3.  
  4. const
  5.     sh=16;
  6.     mul=65536;
  7.     csize=64;
  8.     works: string[30] = 'kablooie.kab';
  9.  
  10. type
  11.     ppack=^pack;
  12.     pload=^load;
  13.     pack=record
  14.         num: integer;
  15.         vary: integer;
  16.         stuff: pload;
  17.         boost: integer;
  18.         next: ppack;
  19.     end;
  20.     load=record
  21.         name: string[30];
  22.         flash: boolean;
  23.         cont: ppack;
  24.         cset: byte;
  25.         decay: byte;
  26.         grav: longint;
  27.         next: pload;
  28.         gnext: pload;
  29.     end;
  30.     ppix=^pix;
  31.     pix=record
  32.         x,y,dx,dy: longint;
  33.         k: byte;
  34.         l: pload;
  35.         last,next: ppix;
  36.     end;
  37.  
  38. var
  39.     disp: ppix;
  40.     batt: pload;
  41.     parts: pload;
  42.     count,loads: integer;
  43.     sina,cosa: array[0..360] of longint;
  44.     test,spark: load;
  45.     testpack: pack;
  46.     launch: pix;
  47.     maxx,maxy: integer;
  48.     f: text;
  49.  
  50. procedure addpix(d: pix);
  51. var p: ppix;
  52. begin
  53.     new(p);
  54.     p^:=d;
  55.     p^.last:=nil;
  56.     p^.next:=disp;
  57.     if disp<>nil then
  58.         disp^.last:=p;
  59.     disp:=p;
  60.     inc(count);
  61. end;
  62.  
  63. procedure rempix(p: ppix);
  64. begin
  65.     if p^.last<>nil then
  66.         p^.last^.next:=p^.next
  67.     else
  68.         disp:=p^.next;
  69.     if p^.next<>nil then
  70.         p^.next^.last:=p^.last;
  71.     dispose(p);
  72.     dec(count);
  73. end;
  74.  
  75. procedure gentrig;
  76. var i: integer;
  77. begin
  78.     for i:=0 to 360 do
  79.     begin
  80.         cosa[i]:=round(cos(pi*i/180)*mul);
  81.         sina[i]:=round(sin(pi*i/180)*mul);
  82.     end;
  83. end;
  84.  
  85. procedure initpix(from: ppix);
  86. var i: integer;
  87.      p: pix;
  88.      th: integer;
  89.      pp: ppack;
  90. begin
  91.     with from^,from^.l^ do
  92.     begin
  93.         if flash then
  94.         begin
  95.             assigncolor(0,white);
  96.             assigncolor(1,grey90);
  97.         end;
  98.         p.x:=x;
  99.         p.y:=y;
  100.         pp:=cont;
  101.         while pp<>nil do
  102.         with pp^ do
  103.         begin
  104.             p.l:=stuff;
  105.             for i:=1 to num+random(vary+1)*2-vary do
  106.             with p do
  107.             begin
  108.                 k:=random(p.l^.decay);
  109.                 th:=random(360);
  110.                 dx:=round(cosa[th]*k*boost/p.l^.decay)+from^.dx;
  111.                 dy:=round(sina[th]*k*boost/p.l^.decay)+from^.dy;
  112.                 addpix(p);
  113.             end;
  114.             pp:=pp^.next;
  115.         end;
  116.         if flash then
  117.         begin
  118.             assigncolor(0,black);
  119.             assigncolor(1,grey10);
  120.         end;
  121.     end;
  122. end;
  123.  
  124. procedure fire;
  125. var i: integer;
  126. begin
  127.     with launch do
  128.     begin
  129.         x:=longint(random(maxx)) shl sh;
  130.         y:=longint(maxy) shl sh;
  131.         if    x>longint(maxx) shl (sh-1) then
  132.             dx:=-round(random*mul)
  133.         else
  134.             dx:=round(random*mul);
  135.         dy:=longint(-5)*mul;
  136.         l:=batt;
  137.         for i:=1 to random(loads) do
  138.             l:=l^.next;
  139.         k:=0;
  140.         addpix(launch);
  141.     end;
  142. end;
  143.  
  144. procedure disppix;
  145. var p,q: ppix;
  146.      xl, yl: longint;
  147. begin
  148.     xl:=longint(maxx) shl sh;
  149.     yl:=longint(maxy) shl sh;
  150.     p:=disp;
  151.     while p<>nil do
  152.     with p^,p^.l^ do
  153.     begin
  154.         q:=p^.next;
  155.         putpixel(x shr sh,y shr sh,1);
  156.         inc(x,dx*maxx div 640);
  157.         inc(y,dy*maxy div 480);
  158.         inc(dy,grav);
  159.         inc(k);
  160.         if (k=decay) or (x<0) or (x>xl) or (y<0) or (y>yl) then
  161.         begin
  162.             if (x>0) and (x<xl) and (y>0) and (y<yl) then
  163.                 initpix(p);
  164.             rempix(p);
  165.         end else
  166.         putpixel(x shr sh,y shr sh,(integer(k)*csize div decay)+cset*csize);
  167.         p:=q;
  168.     end;
  169.     delay(20);
  170.     if count=0 then
  171.         fire;
  172. end;
  173.  
  174. procedure init;
  175. var
  176.     o,m,mm,i: integer;
  177.     s: string;
  178.     col: palette;
  179. begin
  180.     randomize;
  181.     gentrig;
  182.     o:=getmaxmode;
  183.     s:=getmodename(o);
  184.     if paramcount=0 then
  185.     begin
  186.         restorecrtmode;
  187.         writeln('Kablooie (c) 1991 Daniel Egnor -- The Complete Fireworks Simulator!');
  188.         writeln('Requires VGA/MCGA/SVGA');
  189.         writeln;
  190.         writeln('to start: kablooie [kablfile.kab] [m]');
  191.         writeln;
  192.         writeln('[kablfile.kab] is the file name containing firework info.');
  193.         writeln('the default is ',works,'.');
  194.         writeln;
  195.         writeln('[m] is the mode number:');
  196.         writeln;
  197.         writeln('0: 320x200x256,  1: 640x400x256');
  198.         writeln('2: 640x480x256,  3: 800x600x256');
  199.         writeln('4: 1024x768x256, 5: 2048x1025x256 (wow!)');
  200.         writeln;
  201.         writeln('For SVGA modes a VESA-standard BIOS or TSR is required.');
  202.         writeln('Default: ',o,': ',s);
  203.         writeln;
  204.         write('Hit return to continue; <esc> stops it . . .');
  205.         readln;
  206.         setgraphmode(o);
  207.     end else
  208.     begin
  209.         for i:=1 to paramcount do
  210.         begin
  211.             val(paramstr(1),m,mm);
  212.             if (mm=0) and (m>=0) and (m<=o) then
  213.                 setgraphmode(m)
  214.             else
  215.                 works:=paramstr(i);
  216.         end;
  217.     end;
  218.     maxx:=getmaxx;
  219.     maxy:=getmaxy;
  220.     count:=0;
  221.     loads:=0;
  222.     col[1]:=grey10;
  223.     col[2]:=white;
  224.     col[csize-1]:=orange;
  225.     range(col,2,csize-1);
  226.     col[csize]:=white;
  227.     col[2*csize-1]:=blue;
  228.     range(col,csize,2*csize-1);
  229.     col[2*csize]:=white;
  230.     col[3*csize-1]:=red;
  231.     range(col,2*csize,3*csize-1);
  232.     col[3*csize]:=white;
  233.     col[4*csize-1]:=jade;
  234.     range(col,3*csize,4*csize-1);
  235.     setcolors(col,1,1,4*csize-1);
  236.     disp:=nil;
  237.     parts:=nil;
  238. end;
  239.  
  240. procedure addload(l: load);
  241. var p: pload;
  242. begin
  243.     new(p);
  244.     p^:=l;
  245.     p^.next:=batt;
  246.     p^.cont:=nil;
  247.     batt:=p;
  248.     p^.gnext:=parts;
  249.     parts:=p;
  250.     inc(loads);
  251. end;
  252. procedure addpart(l: load);
  253. var p: pload;
  254. begin
  255.     new(p);
  256.     p^:=l;
  257.     p^.next:=nil;
  258.     p^.gnext:=parts;
  259.     p^.cont:=nil;
  260.     parts:=p;
  261. end;
  262. procedure addpack(l: pload; k: pack);
  263. var p: ppack;
  264. begin
  265.     new(p);
  266.     p^:=k;
  267.     p^.next:=l^.cont;
  268.     l^.cont:=p;
  269. end;
  270.  
  271. function findload(n: string): pload;
  272. var p: pload;
  273. begin
  274.     p:=parts;
  275.     n:=copy(n,1,30);
  276.     while (p<>nil) and (p^.name<>n) do
  277.         p:=p^.gnext;
  278.     findload:=p;
  279. end;
  280.  
  281. {$I-}
  282. procedure err(s: string);
  283. begin
  284.     closegraph;
  285.     writeln('Error in file: ',works,': ',s);
  286.     close(f);
  287.     halt(1);
  288. end;
  289.  
  290. function getstr: string;
  291. var s: string;
  292.      i: integer;
  293. begin
  294.     s:='';
  295.     while ((s='') or (s[1]=' ')) and (not eof(f)) do
  296.     begin
  297.         readln(f,s);
  298.     end;
  299.     if (s='') or (s[1]=' ') then
  300.         err('premature EOF.');
  301.     for i:=1 to length(s) do
  302.         s[i]:=upcase(s[i]);
  303.     getstr:=s;
  304. end;
  305.  
  306. function getnum: integer;
  307. var n,nn: integer;
  308. begin
  309.     val(getstr,n,nn);
  310.     if nn<>0 then
  311.         err('invalid number.');
  312.     getnum:=n;
  313. end;
  314. procedure readfile;
  315. var l: load;
  316.      p: pack;
  317.      s,t: string;
  318. begin
  319.     assign(f,works);
  320.     reset(f);
  321.     if ioresult<>0 then
  322.         err('cannot be opened.');
  323.     while not eof(f) do
  324.     begin
  325.         s:=getstr;
  326.         if (s<>'FIREWORK') and (s<>'PACKING') then
  327.             err('FIREWORK or PACKING expected.');
  328.         l.name:=getstr;
  329.         t:=getstr;
  330.         if (t<>'FLASH') and (t<>'NOFLASH') then
  331.             err('FLASH or NOFLASH expected.');
  332.         l.flash:=(t='FLASH');
  333.         t:=getstr;
  334.         if (t<>'RED') and (t<>'YELLOW') and (t<>'GREEN') and (t<>'BLUE') then
  335.             err('color name expected.');
  336.         if t='RED' then l.cset:=2;
  337.         if t='YELLOW' then l.cset:=0;
  338.         if t='GREEN' then l.cset:=3;
  339.         if t='BLUE' then l.cset:=1;
  340.         l.decay:=getnum;
  341.         l.grav:=getnum;
  342.         l.grav:=l.grav*mul div 100;
  343.         if s='FIREWORK' then addload(l) else addpart(l);
  344.         s:=getstr;
  345.         while s<>'END' do
  346.         begin
  347.             p.stuff:=findload(s);
  348.             if p.stuff=nil then
  349.                 err('packing not found.');
  350.             p.num:=getnum;
  351.             p.vary:=getnum;
  352.             p.boost:=getnum;
  353.             addpack(parts,p);
  354.             s:=getstr;
  355.         end;
  356.     end;
  357.     close(f);
  358. end;
  359. {$I+}
  360.  
  361. begin
  362.     init;
  363.     readfile;
  364.     repeat
  365.         cleardevice;
  366.         while not keypressed do
  367.             disppix;
  368.     until readkey=#27;
  369.     closegraph;
  370. end.